home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 May / Macworld (1998-05).dmg / Serious Demos / TeamWave 3.0 / TeamWave Workplace / TeamWave Workplace.rsrc / TEXT_7_menu.txt < prev    next >
Text File  |  1998-02-13  |  34KB  |  1,236 lines
  1. # menu.tcl --
  2. #
  3. # This file defines the default bindings for Tk menus and menubuttons.
  4. # It also implements keyboard traversal of menus and implements a few
  5. # other utility procedures related to menus.
  6. #
  7. # SCCS: @(#) menu.tcl 1.103 97/10/31 15:26:08
  8. #
  9. # Copyright (c) 1992-1994 The Regents of the University of California.
  10. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14. #
  15.  
  16. #-------------------------------------------------------------------------
  17. # Elements of tkPriv that are used in this file:
  18. #
  19. # cursor -        Saves the -cursor option for the posted menubutton.
  20. # focus -        Saves the focus during a menu selection operation.
  21. #            Focus gets restored here when the menu is unposted.
  22. # grabGlobal -        Used in conjunction with tkPriv(oldGrab):  if
  23. #            tkPriv(oldGrab) is non-empty, then tkPriv(grabGlobal)
  24. #            contains either an empty string or "-global" to
  25. #            indicate whether the old grab was a local one or
  26. #            a global one.
  27. # inMenubutton -    The name of the menubutton widget containing
  28. #            the mouse, or an empty string if the mouse is
  29. #            not over any menubutton.
  30. # menuBar -        The name of the menubar that is the root
  31. #            of the cascade hierarchy which is currently
  32. #            posted. This is null when there is no menu currently
  33. #            being pulled down from a menu bar.
  34. # oldGrab -        Window that had the grab before a menu was posted.
  35. #            Used to restore the grab state after the menu
  36. #            is unposted.  Empty string means there was no
  37. #            grab previously set.
  38. # popup -        If a menu has been popped up via tk_popup, this
  39. #            gives the name of the menu.  Otherwise this
  40. #            value is empty.
  41. # postedMb -        Name of the menubutton whose menu is currently
  42. #            posted, or an empty string if nothing is posted
  43. #            A grab is set on this widget.
  44. # relief -        Used to save the original relief of the current
  45. #            menubutton.
  46. # window -        When the mouse is over a menu, this holds the
  47. #            name of the menu;  it's cleared when the mouse
  48. #            leaves the menu.
  49. # tearoff -        Whether the last menu posted was a tearoff or not.
  50. #            This is true always for unix, for tearoffs for Mac
  51. #            and Windows.
  52. # activeMenu -        This is the last active menu for use
  53. #            with the <<MenuSelect>> virtual event.
  54. # activeItem -        This is the last active menu item for
  55. #            use with the <<MenuSelect>> virtual event.
  56. #-------------------------------------------------------------------------
  57.  
  58. #-------------------------------------------------------------------------
  59. # Overall note:
  60. # This file is tricky because there are five different ways that menus
  61. # can be used:
  62. #
  63. # 1. As a pulldown from a menubutton. In this style, the variable 
  64. #    tkPriv(postedMb) identifies the posted menubutton.
  65. # 2. As a torn-off menu copied from some other menu.  In this style
  66. #    tkPriv(postedMb) is empty, and menu's type is "tearoff".
  67. # 3. As an option menu, triggered from an option menubutton.  In this
  68. #    style tkPriv(postedMb) identifies the posted menubutton.
  69. # 4. As a popup menu.  In this style tkPriv(postedMb) is empty and
  70. #    the top-level menu's type is "normal".
  71. # 5. As a pulldown from a menubar. The variable tkPriv(menubar) has
  72. #    the owning menubar, and the menu itself is of type "normal".
  73. #
  74. # The various binding procedures use the  state described above to
  75. # distinguish the various cases and take different actions in each
  76. # case.
  77. #-------------------------------------------------------------------------
  78.  
  79. #-------------------------------------------------------------------------
  80. # The code below creates the default class bindings for menus
  81. # and menubuttons.
  82. #-------------------------------------------------------------------------
  83.  
  84. bind Menubutton <FocusIn> {}
  85. bind Menubutton <Enter> {
  86.     tkMbEnter %W
  87. }
  88. bind Menubutton <Leave> {
  89.     tkMbLeave %W
  90. }
  91. bind Menubutton <1> {
  92.     if {$tkPriv(inMenubutton) != ""} {
  93.     tkMbPost $tkPriv(inMenubutton) %X %Y
  94.     }
  95. }
  96. bind Menubutton <Motion> {
  97.     tkMbMotion %W up %X %Y
  98. }
  99. bind Menubutton <B1-Motion> {
  100.     tkMbMotion %W down %X %Y
  101. }
  102. bind Menubutton <ButtonRelease-1> {
  103.     tkMbButtonUp %W
  104. }
  105. bind Menubutton <space> {
  106.     tkMbPost %W
  107.     tkMenuFirstEntry [%W cget -menu]
  108. }
  109.  
  110. # Must set focus when mouse enters a menu, in order to allow
  111. # mixed-mode processing using both the mouse and the keyboard.
  112. # Don't set the focus if the event comes from a grab release,
  113. # though:  such an event can happen after as part of unposting
  114. # a cascaded chain of menus, after the focus has already been
  115. # restored to wherever it was before menu selection started.
  116.  
  117. bind Menu <FocusIn> {}
  118.  
  119. bind Menu <Enter> {
  120.     set tkPriv(window) %W
  121.     if {[%W cget -type] == "tearoff"} {
  122.     if {"%m" != "NotifyUngrab"} {
  123.         if {$tcl_platform(platform) == "unix"} {
  124.         tk_menuSetFocus %W
  125.         }
  126.     }
  127.     }
  128.     tkMenuMotion %W %x %y %s
  129. }
  130.  
  131. bind Menu <Leave> {
  132.     tkMenuLeave %W %X %Y %s
  133. }
  134. bind Menu <Motion> {
  135.     tkMenuMotion %W %x %y %s
  136. }
  137. bind Menu <ButtonPress> {
  138.     tkMenuButtonDown %W
  139. }
  140. bind Menu <ButtonRelease> {
  141.    tkMenuInvoke %W 1
  142. }
  143. bind Menu <space> {
  144.     tkMenuInvoke %W 0
  145. }
  146. bind Menu <Return> {
  147.     tkMenuInvoke %W 0
  148. }
  149. bind Menu <Escape> {
  150.     tkMenuEscape %W
  151. }
  152. bind Menu <Left> {
  153.     tkMenuLeftArrow %W
  154. }
  155. bind Menu <Right> {
  156.     tkMenuRightArrow %W
  157. }
  158. bind Menu <Up> {
  159.     tkMenuUpArrow %W
  160. }
  161. bind Menu <Down> {
  162.     tkMenuDownArrow %W
  163. }
  164. bind Menu <KeyPress> {
  165.     tkTraverseWithinMenu %W %A
  166. }
  167.  
  168. # The following bindings apply to all windows, and are used to
  169. # implement keyboard menu traversal.
  170.  
  171. if {$tcl_platform(platform) == "unix"} {
  172.     bind all <Alt-KeyPress> {
  173.     tkTraverseToMenu %W %A
  174.     }
  175.  
  176.     bind all <F10> {
  177.     tkFirstMenu %W
  178.     }
  179. } else {
  180.     bind Menubutton <Alt-KeyPress> {
  181.     tkTraverseToMenu %W %A
  182.     }
  183.  
  184.     bind Menubutton <F10> {
  185.     tkFirstMenu %W
  186.     }
  187. }
  188.  
  189. # tkMbEnter --
  190. # This procedure is invoked when the mouse enters a menubutton
  191. # widget.  It activates the widget unless it is disabled.  Note:
  192. # this procedure is only invoked when mouse button 1 is *not* down.
  193. # The procedure tkMbB1Enter is invoked if the button is down.
  194. #
  195. # Arguments:
  196. # w -            The  name of the widget.
  197.  
  198. proc tkMbEnter w {
  199.     global tkPriv
  200.  
  201.     if {$tkPriv(inMenubutton) != ""} {
  202.     tkMbLeave $tkPriv(inMenubutton)
  203.     }
  204.     set tkPriv(inMenubutton) $w
  205.     if {[$w cget -state] != "disabled"} {
  206.     $w configure -state active
  207.     }
  208. }
  209.  
  210. # tkMbLeave --
  211. # This procedure is invoked when the mouse leaves a menubutton widget.
  212. # It de-activates the widget, if the widget still exists.
  213. #
  214. # Arguments:
  215. # w -            The  name of the widget.
  216.  
  217. proc tkMbLeave w {
  218.     global tkPriv
  219.  
  220.     set tkPriv(inMenubutton) {}
  221.     if ![winfo exists $w] {
  222.     return
  223.     }
  224.     if {[$w cget -state] == "active"} {
  225.     $w configure -state normal
  226.     }
  227. }
  228.  
  229. # tkMbPost --
  230. # Given a menubutton, this procedure does all the work of posting
  231. # its associated menu and unposting any other menu that is currently
  232. # posted.
  233. #
  234. # Arguments:
  235. # w -            The name of the menubutton widget whose menu
  236. #            is to be posted.
  237. # x, y -        Root coordinates of cursor, used for positioning
  238. #            option menus.  If not specified, then the center
  239. #            of the menubutton is used for an option menu.
  240.  
  241. proc tkMbPost {w {x {}} {y {}}} {
  242.     global tkPriv errorInfo
  243.     global tcl_platform
  244.  
  245.     if {([$w cget -state] == "disabled") || ($w == $tkPriv(postedMb))} {
  246.     return
  247.     }
  248.     set menu [$w cget -menu]
  249.     if {$menu == ""} {
  250.     return
  251.     }
  252.     set tearoff [expr {($tcl_platform(platform) == "unix") \
  253.              || ([$menu cget -type] == "tearoff")}]
  254.     if {[string first $w $menu] != 0} {
  255.     error "can't post $menu:  it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
  256.     }
  257.     set cur $tkPriv(postedMb)
  258.     if {$cur != ""} {
  259.     tkMenuUnpost {}
  260.     }
  261.     set tkPriv(cursor) [$w cget -cursor]
  262.     set tkPriv(relief) [$w cget -relief]
  263.     $w configure -cursor arrow
  264.     $w configure -relief raised
  265.  
  266.     set tkPriv(postedMb) $w
  267.     set tkPriv(focus) [focus]
  268.     $menu activate none
  269.     tkGenerateMenuSelect $menu
  270.  
  271.     # If this looks like an option menubutton then post the menu so
  272.     # that the current entry is on top of the mouse.  Otherwise post
  273.     # the menu just below the menubutton, as for a pull-down.
  274.  
  275.     update idletasks
  276.     if [catch {
  277.          switch [$w cget -direction] {
  278.             above {
  279.                 set x [winfo rootx $w]
  280.                 set y [expr [winfo rooty $w] - [winfo reqheight $menu]]
  281.                 $menu post $x $y
  282.             }
  283.             below {
  284.                 set x [winfo rootx $w]
  285.                 set y [expr [winfo rooty $w] + [winfo height $w]]
  286.                 $menu post $x $y
  287.             }
  288.             left {
  289.                 set x [expr [winfo rootx $w] - [winfo reqwidth $menu]]
  290.                 set y [expr (2 * [winfo rooty $w] + [winfo height $w]) / 2]
  291.                 set entry [tkMenuFindName $menu [$w cget -text]]
  292.                 if [$w cget -indicatoron] {
  293.             if {$entry == [$menu index last]} {
  294.                 incr y [expr -([$menu yposition $entry] \
  295.                     + [winfo reqheight $menu])/2]
  296.             } else {
  297.                 incr y [expr -([$menu yposition $entry] \
  298.                     + [$menu yposition [expr $entry+1]])/2]
  299.             }
  300.                 }
  301.                 $menu post $x $y
  302.                 if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} {
  303.                     $menu activate $entry
  304.             tkGenerateMenuSelect $menu
  305.                 }
  306.             }
  307.             right {
  308.                 set x [expr [winfo rootx $w] + [winfo width $w]]
  309.                 set y [expr (2 * [winfo rooty $w] + [winfo height $w]) / 2]
  310.                 set entry [tkMenuFindName $menu [$w cget -text]]
  311.                 if [$w cget -indicatoron] {
  312.             if {$entry == [$menu index last]} {
  313.                 incr y [expr -([$menu yposition $entry] \
  314.                     + [winfo reqheight $menu])/2]
  315.             } else {
  316.                 incr y [expr -([$menu yposition $entry] \
  317.                     + [$menu yposition [expr $entry+1]])/2]
  318.             }
  319.                 }
  320.                 $menu post $x $y
  321.                 if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} {
  322.                     $menu activate $entry
  323.             tkGenerateMenuSelect $menu
  324.                 }
  325.             }
  326.             default {
  327.                 if [$w cget -indicatoron] {
  328.                 if {$y == ""} {
  329.             set x [expr [winfo rootx $w] + [winfo width $w]/2]
  330.             set y [expr [winfo rooty $w] + [winfo height $w]/2]
  331.                 }
  332.                 tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]]
  333.         } else {
  334.                 $menu post [winfo rootx $w] [expr [winfo rooty $w]+[winfo height $w]]
  335.                 }  
  336.             }
  337.          }
  338.      } msg] {
  339.     # Error posting menu (e.g. bogus -postcommand). Unpost it and
  340.     # reflect the error.
  341.     
  342.     set savedInfo $errorInfo
  343.     tkMenuUnpost {}
  344.     error $msg $savedInfo
  345.  
  346.     }
  347.  
  348.     set tkPriv(tearoff) $tearoff
  349.     if {$tearoff != 0} {
  350.         focus $menu
  351.         tkSaveGrabInfo $w
  352.         grab -global $w
  353.     }
  354. }
  355.  
  356. # tkMenuUnpost --
  357. # This procedure unposts a given menu, plus all of its ancestors up
  358. # to (and including) a menubutton, if any.  It also restores various
  359. # values to what they were before the menu was posted, and releases
  360. # a grab if there's a menubutton involved.  Special notes:
  361. # 1. It's important to unpost all menus before releasing the grab, so
  362. #    that any Enter-Leave events (e.g. from menu back to main
  363. #    application) have mode NotifyGrab.
  364. # 2. Be sure to enclose various groups of commands in "catch" so that
  365. #    the procedure will complete even if the menubutton or the menu
  366. #    or the grab window has been deleted.
  367. #
  368. # Arguments:
  369. # menu -        Name of a menu to unpost.  Ignored if there
  370. #            is a posted menubutton.
  371.  
  372. proc tkMenuUnpost menu {
  373.     global tcl_platform
  374.     global tkPriv
  375.     set mb $tkPriv(postedMb)
  376.  
  377.     # Restore focus right away (otherwise X will take focus away when
  378.     # the menu is unmapped and under some window managers (e.g. olvwm)
  379.     # we'll lose the focus completely).
  380.  
  381.     catch {focus $tkPriv(focus)}
  382.     set tkPriv(focus) ""
  383.  
  384.     # Unpost menu(s) and restore some stuff that's dependent on
  385.     # what was posted.
  386.  
  387.     catch {
  388.     if {$mb != ""} {
  389.         set menu [$mb cget -menu]
  390.         $menu unpost
  391.         set tkPriv(postedMb) {}
  392.         $mb configure -cursor $tkPriv(cursor)
  393.         $mb configure -relief $tkPriv(relief)
  394.     } elseif {$tkPriv(popup) != ""} {
  395.         $tkPriv(popup) unpost
  396.         set tkPriv(popup) {}
  397.     } elseif {(!([$menu cget -type] == "menubar")
  398.         && !([$menu cget -type] == "tearoff"))} {
  399.         # We're in a cascaded sub-menu from a torn-off menu or popup.
  400.         # Unpost all the menus up to the toplevel one (but not
  401.         # including the top-level torn-off one) and deactivate the
  402.         # top-level torn off menu if there is one.
  403.  
  404.         while 1 {
  405.         set parent [winfo parent $menu]
  406.         if {([winfo class $parent] != "Menu")
  407.             || ![winfo ismapped $parent]} {
  408.             break
  409.         }
  410.         $parent activate none
  411.         $parent postcascade none
  412.         tkGenerateMenuSelect $parent
  413.         set type [$parent cget -type]
  414.         if {($type == "menubar")|| ($type == "tearoff")} {
  415.             break
  416.         }
  417.         set menu $parent
  418.         }
  419.         if {[$menu cget -type] != "menubar"} {
  420.         $menu unpost
  421.         }
  422.     }
  423.     }
  424.  
  425.     if {($tkPriv(tearoff) != 0) || ($tkPriv(menuBar) != "")} {
  426.         # Release grab, if any, and restore the previous grab, if there
  427.         # was one.
  428.  
  429.     if {$menu != ""} {
  430.         set grab [grab current $menu]
  431.         if {$grab != ""} {
  432.         grab release $grab
  433.         }
  434.     }
  435.     tkRestoreOldGrab
  436.     if {$tkPriv(menuBar) != ""} {
  437.         $tkPriv(menuBar) configure -cursor $tkPriv(cursor)
  438.         set tkPriv(menuBar) {}
  439.     }
  440.     if {$tcl_platform(platform) != "unix"} {
  441.         set tkPriv(tearoff) 0
  442.     }
  443.     }
  444. }
  445.  
  446. # tkMbMotion --
  447. # This procedure handles mouse motion events inside menubuttons, and
  448. # also outside menubuttons when a menubutton has a grab (e.g. when a
  449. # menu selection operation is in progress).
  450. #
  451. # Arguments:
  452. # w -            The name of the menubutton widget.
  453. # upDown -         "down" means button 1 is pressed, "up" means
  454. #            it isn't.
  455. # rootx, rooty -    Coordinates of mouse, in (virtual?) root window.
  456.  
  457. proc tkMbMotion {w upDown rootx rooty} {
  458.     global tkPriv
  459.  
  460.     if {$tkPriv(inMenubutton) == $w} {
  461.     return
  462.     }
  463.     set new [winfo containing $rootx $rooty]
  464.     if {($new != $tkPriv(inMenubutton)) && (($new == "")
  465.         || ([winfo toplevel $new] == [winfo toplevel $w]))} {
  466.     if {$tkPriv(inMenubutton) != ""} {
  467.         tkMbLeave $tkPriv(inMenubutton)
  468.     }
  469.     if {($new != "") && ([winfo class $new] == "Menubutton")
  470.         && ([$new cget -indicatoron] == 0)
  471.         && ([$w cget -indicatoron] == 0)} {
  472.         if {$upDown == "down"} {
  473.         tkMbPost $new $rootx $rooty
  474.         } else {
  475.         tkMbEnter $new
  476.         }
  477.     }
  478.     }
  479. }
  480.  
  481. # tkMbButtonUp --
  482. # This procedure is invoked to handle button 1 releases for menubuttons.
  483. # If the release happens inside the menubutton then leave its menu
  484. # posted with element 0 activated.  Otherwise, unpost the menu.
  485. #
  486. # Arguments:
  487. # w -            The name of the menubutton widget.
  488.  
  489. proc tkMbButtonUp w {
  490.     global tkPriv
  491.     global tcl_platform
  492.  
  493.     set tearoff [expr {($tcl_platform(platform) == "unix") \
  494.              || ([[$w cget -menu] cget -type] == "tearoff")}]
  495.     if {($tearoff != 0) && ($tkPriv(postedMb) == $w) 
  496.         && ($tkPriv(inMenubutton) == $w)} {
  497.     tkMenuFirstEntry [$tkPriv(postedMb) cget -menu]
  498.     } else {
  499.     tkMenuUnpost {}
  500.     }
  501. }
  502.  
  503. # tkMenuMotion --
  504. # This procedure is called to handle mouse motion events for menus.
  505. # It does two things.  First, it resets the active element in the
  506. # menu, if the mouse is over the menu.  Second, if a mouse button
  507. # is down, it posts and unposts cascade entries to match the mouse
  508. # position.
  509. #
  510. # Arguments:
  511. # menu -        The menu window.
  512. # x -            The x position of the mouse.
  513. # y -            The y position of the mouse.
  514. # state -        Modifier state (tells whether buttons are down).
  515.  
  516. proc tkMenuMotion {menu x y state} {
  517.     global tkPriv
  518.     if {$menu == $tkPriv(window)} {
  519.     if {[$menu cget -type] == "menubar"} {
  520.         if {[info exists tkPriv(focus)] && \
  521.             ([string compare $menu $tkPriv(focus)] != 0)} {
  522.         $menu activate @$x,$y
  523.         tkGenerateMenuSelect $menu
  524.         }
  525.     } else {
  526.         $menu activate @$x,$y
  527.         tkGenerateMenuSelect $menu
  528.     }
  529.     }
  530.     if {($state & 0x1f00) != 0} {
  531.     $menu postcascade active
  532.     }
  533. }
  534.  
  535. # tkMenuButtonDown --
  536. # Handles button presses in menus.  There are a couple of tricky things
  537. # here:
  538. # 1. Change the posted cascade entry (if any) to match the mouse position.
  539. # 2. If there is a posted menubutton, must grab to the menubutton;  this
  540. #    overrrides the implicit grab on button press, so that the menu
  541. #    button can track mouse motions over other menubuttons and change
  542. #    the posted menu.
  543. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu
  544. #    or one of its descendants) must grab to the top-level menu so that
  545. #    we can track mouse motions across the entire menu hierarchy.
  546. #
  547. # Arguments:
  548. # menu -        The menu window.
  549.  
  550. proc tkMenuButtonDown menu {
  551.     global tkPriv
  552.     global tcl_platform
  553.     $menu postcascade active
  554.     if {$tkPriv(postedMb) != ""} {
  555.     grab -global $tkPriv(postedMb)
  556.     } else {
  557.     while {([$menu cget -type] == "normal") 
  558.         && ([winfo class [winfo parent $menu]] == "Menu")
  559.         && [winfo ismapped [winfo parent $menu]]} {
  560.         set menu [winfo parent $menu]
  561.     }
  562.  
  563.     if {$tkPriv(menuBar) == {}} {
  564.         set tkPriv(menuBar) $menu
  565.         set tkPriv(cursor) [$menu cget -cursor]
  566.         $menu configure -cursor arrow
  567.         }
  568.  
  569.     # Don't update grab information if the grab window isn't changing.
  570.     # Otherwise, we'll get an error when we unpost the menus and
  571.     # restore the grab, since the old grab window will not be viewable
  572.     # anymore.
  573.  
  574.     if {$menu != [grab current $menu]} {
  575.         tkSaveGrabInfo $menu
  576.     }
  577.  
  578.     # Must re-grab even if the grab window hasn't changed, in order
  579.     # to release the implicit grab from the button press.
  580.  
  581.     if {$tcl_platform(platform) == "unix"} {
  582.         grab -global $menu
  583.     }
  584.     }
  585. }
  586.  
  587. # tkMenuLeave --
  588. # This procedure is invoked to handle Leave events for a menu.  It
  589. # deactivates everything unless the active element is a cascade element
  590. # and the mouse is now over the submenu.
  591. #
  592. # Arguments:
  593. # menu -        The menu window.
  594. # rootx, rooty -    Root coordinates of mouse.
  595. # state -        Modifier state.
  596.  
  597. proc tkMenuLeave {menu rootx rooty state} {
  598.     global tkPriv
  599.     set tkPriv(window) {}
  600.     if {[$menu index active] == "none"} {
  601.     return
  602.     }
  603.     if {([$menu type active] == "cascade")
  604.         && ([winfo containing $rootx $rooty]
  605.         == [$menu entrycget active -menu])} {
  606.     return
  607.     }
  608.     $menu activate none
  609.     tkGenerateMenuSelect $menu
  610. }
  611.  
  612. # tkMenuInvoke --
  613. # This procedure is invoked when button 1 is released over a menu.
  614. # It invokes the appropriate menu action and unposts the menu if
  615. # it came from a menubutton.
  616. #
  617. # Arguments:
  618. # w -            Name of the menu widget.
  619. # buttonRelease -    1 means this procedure is called because of
  620. #            a button release;  0 means because of keystroke.
  621.  
  622. proc tkMenuInvoke {w buttonRelease} {
  623.     global tkPriv
  624.  
  625.     if {$buttonRelease && ($tkPriv(window) == "")} {
  626.     # Mouse was pressed over a menu without a menu button, then
  627.     # dragged off the menu (possibly with a cascade posted) and
  628.     # released.  Unpost everything and quit.
  629.  
  630.     $w postcascade none
  631.     $w activate none
  632.     event generate $w <<MenuSelect>>
  633.     tkMenuUnpost $w
  634.     return
  635.     }
  636.     if {[$w type active] == "cascade"} {
  637.     $w postcascade active
  638.     set menu [$w entrycget active -menu]
  639.     tkMenuFirstEntry $menu
  640.     } elseif {[$w type active] == "tearoff"} {
  641.     tkMenuUnpost $w
  642.     tkTearOffMenu $w
  643.     } elseif {[$w cget -type] == "menubar"} {
  644.     $w postcascade none
  645.     $w activate none
  646.     event generate $w <<MenuSelect>>
  647.     tkMenuUnpost $w
  648.     } else {
  649.     tkMenuUnpost $w
  650.     uplevel #0 [list $w invoke active]
  651.     }
  652. }
  653.  
  654. # tkMenuEscape --
  655. # This procedure is invoked for the Cancel (or Escape) key.  It unposts
  656. # the given menu and, if it is the top-level menu for a menu button,
  657. # unposts the menu button as well.
  658. #
  659. # Arguments:
  660. # menu -        Name of the menu window.
  661.  
  662. proc tkMenuEscape menu {
  663.     set parent [winfo parent $menu]
  664.     if {([winfo class $parent] != "Menu")} {
  665.     tkMenuUnpost $menu
  666.     } elseif {([$parent cget -type] == "menubar")} {
  667.     tkMenuUnpost $menu
  668.     tkRestoreOldGrab
  669.     } else {
  670.     tkMenuNextMenu $menu left
  671.     }
  672. }
  673.  
  674. # The following routines handle arrow keys. Arrow keys behave
  675. # differently depending on whether the menu is a menu bar or not.
  676.  
  677. proc tkMenuUpArrow {menu} {
  678.     if {[$menu cget -type] == "menubar"} {
  679.     tkMenuNextMenu $menu left
  680.     } else {
  681.     tkMenuNextEntry $menu -1
  682.     }
  683. }
  684.  
  685. proc tkMenuDownArrow {menu} {
  686.     if {[$menu cget -type] == "menubar"} {
  687.     tkMenuNextMenu $menu right
  688.     } else {
  689.     tkMenuNextEntry $menu 1
  690.     }
  691. }
  692.  
  693. proc tkMenuLeftArrow {menu} {
  694.     if {[$menu cget -type] == "menubar"} {
  695.     tkMenuNextEntry $menu -1
  696.     } else {
  697.     tkMenuNextMenu $menu left
  698.     }
  699. }
  700.  
  701. proc tkMenuRightArrow {menu} {
  702.     if {[$menu cget -type] == "menubar"} {
  703.     tkMenuNextEntry $menu 1
  704.     } else {
  705.     tkMenuNextMenu $menu right
  706.     }
  707. }
  708.  
  709. # tkMenuNextMenu --
  710. # This procedure is invoked to handle "left" and "right" traversal
  711. # motions in menus.  It traverses to the next menu in a menu bar,
  712. # or into or out of a cascaded menu.
  713. #
  714. # Arguments:
  715. # menu -        The menu that received the keyboard
  716. #            event.
  717. # direction -        Direction in which to move: "left" or "right"
  718.  
  719. proc tkMenuNextMenu {menu direction} {
  720.     global tkPriv
  721.  
  722.     # First handle traversals into and out of cascaded menus.
  723.  
  724.     if {$direction == "right"} {
  725.     set count 1
  726.     set parent [winfo parent $menu]
  727.     set class [winfo class $parent]
  728.     if {[$menu type active] == "cascade"} {
  729.         $menu postcascade active
  730.         set m2 [$menu entrycget active -menu]
  731.         if {$m2 != ""} {
  732.         tkMenuFirstEntry $m2
  733.         }
  734.         return
  735.     } else {
  736.         set parent [winfo parent $menu]
  737.         while {($parent != ".")} {
  738.         if {([winfo class $parent] == "Menu")
  739.             && ([$parent cget -type] == "menubar")} {
  740.             tk_menuSetFocus $parent
  741.             tkMenuNextEntry $parent 1
  742.             return
  743.         }
  744.         set parent [winfo parent $parent]
  745.         }
  746.     }
  747.     } else {
  748.     set count -1
  749.     set m2 [winfo parent $menu]
  750.     if {[winfo class $m2] == "Menu"} {
  751.         if {[$m2 cget -type] != "menubar"} {
  752.         $menu activate none
  753.         tkGenerateMenuSelect $menu
  754.         tk_menuSetFocus $m2
  755.         
  756.         # This code unposts any posted submenu in the parent.
  757.         
  758.         set tmp [$m2 index active]
  759.         $m2 activate none
  760.         $m2 activate $tmp
  761.         return
  762.         }
  763.     }
  764.     }
  765.  
  766.     # Can't traverse into or out of a cascaded menu.  Go to the next
  767.     # or previous menubutton, if that makes sense.
  768.  
  769.     set m2 [winfo parent $menu]
  770.     if {[winfo class $m2] == "Menu"} {
  771.     if {[$m2 cget -type] == "menubar"} {
  772.         tk_menuSetFocus $m2
  773.         tkMenuNextEntry $m2 -1
  774.         return
  775.     }
  776.     }
  777.  
  778.     set w $tkPriv(postedMb)
  779.     if {$w == ""} {
  780.     return
  781.     }
  782.     set buttons [winfo children [winfo parent $w]]
  783.     set length [llength $buttons]
  784.     set i [expr [lsearch -exact $buttons $w] + $count]
  785.     while 1 {
  786.     while {$i < 0} {
  787.         incr i $length
  788.     }
  789.     while {$i >= $length} {
  790.         incr i -$length
  791.     }
  792.     set mb [lindex $buttons $i]
  793.     if {([winfo class $mb] == "Menubutton")
  794.         && ([$mb cget -state] != "disabled")
  795.         && ([$mb cget -menu] != "")
  796.         && ([[$mb cget -menu] index last] != "none")} {
  797.         break
  798.     }
  799.     if {$mb == $w} {
  800.         return
  801.     }
  802.     incr i $count
  803.     }
  804.     tkMbPost $mb
  805.     tkMenuFirstEntry [$mb cget -menu]
  806. }
  807.  
  808. # tkMenuNextEntry --
  809. # Activate the next higher or lower entry in the posted menu,
  810. # wrapping around at the ends.  Disabled entries are skipped.
  811. #
  812. # Arguments:
  813. # menu -            Menu window that received the keystroke.
  814. # count -            1 means go to the next lower entry,
  815. #                -1 means go to the next higher entry.
  816.  
  817. proc tkMenuNextEntry {menu count} {
  818.     global tkPriv
  819.  
  820.     if {[$menu index last] == "none"} {
  821.     return
  822.     }
  823.     set length [expr [$menu index last]+1]
  824.     set quitAfter $length
  825.     set active [$menu index active]
  826.     if {$active == "none"} {
  827.     set i 0
  828.     } else {
  829.     set i [expr $active + $count]
  830.     }
  831.     while 1 {
  832.     if {$quitAfter <= 0} {
  833.         # We've tried every entry in the menu.  Either there are
  834.         # none, or they're all disabled.  Just give up.
  835.  
  836.         return
  837.     }
  838.     while {$i < 0} {
  839.         incr i $length
  840.     }
  841.     while {$i >= $length} {
  842.         incr i -$length
  843.     }
  844.     if {[catch {$menu entrycget $i -state} state] == 0} {
  845.         if {$state != "disabled"} {
  846.         break
  847.         }
  848.     }
  849.     if {$i == $active} {
  850.         return
  851.     }
  852.     incr i $count
  853.     incr quitAfter -1
  854.     }
  855.     $menu activate $i
  856.     tkGenerateMenuSelect $menu
  857.     if {[$menu type $i] == "cascade"} {
  858.     set cascade [$menu entrycget $i -menu]
  859.     if {[string compare $cascade ""] != 0} {
  860.         $menu postcascade $i
  861.         tkMenuFirstEntry $cascade
  862.     }
  863.     }
  864. }
  865.  
  866. # tkMenuFind --
  867. # This procedure searches the entire window hierarchy under w for
  868. # a menubutton that isn't disabled and whose underlined character
  869. # is "char" or an entry in a menubar that isn't disabled and whose
  870. # underlined character is "char".
  871. # It returns the name of that window, if found, or an
  872. # empty string if no matching window was found.  If "char" is an
  873. # empty string then the procedure returns the name of the first
  874. # menubutton found that isn't disabled.
  875. #
  876. # Arguments:
  877. # w -                Name of window where key was typed.
  878. # char -            Underlined character to search for;
  879. #                may be either upper or lower case, and
  880. #                will match either upper or lower case.
  881.  
  882. proc tkMenuFind {w char} {
  883.     global tkPriv
  884.     set char [string tolower $char]
  885.     set windowlist [winfo child $w]
  886.  
  887.     foreach child $windowlist {
  888.     switch [winfo class $child] {
  889.         Menu {
  890.         if {[$child cget -type] == "menubar"} {
  891.             if {$char == ""} {
  892.             return $child
  893.             }
  894.             set last [$child index last]
  895.             for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {
  896.             if {[$child type $i] == "separator"} {
  897.                 continue
  898.             }
  899.             set char2 [string index [$child entrycget $i -label] \
  900.                 [$child entrycget $i -underline]]
  901.             if {([string compare $char [string tolower $char2]] \
  902.                 == 0) || ($char == "")} {
  903.                 if {[$child entrycget $i -state] != "disabled"} {
  904.                 return $child
  905.                 }
  906.             }
  907.             }
  908.         }
  909.         }
  910.     }
  911.     }
  912.  
  913.     foreach child $windowlist {
  914.     switch [winfo class $child] {
  915.         Menubutton {
  916.         set char2 [string index [$child cget -text] \
  917.             [$child cget -underline]]
  918.         if {([string compare $char [string tolower $char2]] == 0)
  919.             || ($char == "")} {
  920.             if {[$child cget -state] != "disabled"} {
  921.             return $child
  922.             }
  923.         }
  924.         }
  925.  
  926.         default {
  927.         set match [tkMenuFind $child $char]
  928.         if {$match != ""} {
  929.             return $match
  930.         }
  931.         }
  932.     }
  933.     }
  934.     return {}
  935. }
  936.  
  937. # tkTraverseToMenu --
  938. # This procedure implements keyboard traversal of menus.  Given an
  939. # ASCII character "char", it looks for a menubutton with that character
  940. # underlined.  If one is found, it posts the menubutton's menu
  941. #
  942. # Arguments:
  943. # w -                Window in which the key was typed (selects
  944. #                a toplevel window).
  945. # char -            Character that selects a menu.  The case
  946. #                is ignored.  If an empty string, nothing
  947. #                happens.
  948.  
  949. proc tkTraverseToMenu {w char} {
  950.     global tkPriv
  951.     if {$char == ""} {
  952.     return
  953.     }
  954.     while {[winfo class $w] == "Menu"} {
  955.     if {([$w cget -type] != "menubar") && ($tkPriv(postedMb) == "")} {
  956.         return
  957.     }
  958.     if {[$w cget -type] == "menubar"} {
  959.         break
  960.     }
  961.     set w [winfo parent $w]
  962.     }
  963.     set w [tkMenuFind [winfo toplevel $w] $char]
  964.     if {$w != ""} {
  965.     if {[winfo class $w] == "Menu"} {
  966.         tk_menuSetFocus $w
  967.         set tkPriv(window) $w
  968.         tkSaveGrabInfo $w
  969.         grab -global $w
  970.         tkTraverseWithinMenu $w $char
  971.     } else {
  972.         tkMbPost $w
  973.         tkMenuFirstEntry [$w cget -menu]
  974.     }
  975.     }
  976. }
  977.  
  978. # tkFirstMenu --
  979. # This procedure traverses to the first menubutton in the toplevel
  980. # for a given window, and posts that menubutton's menu.
  981. #
  982. # Arguments:
  983. # w -                Name of a window.  Selects which toplevel
  984. #                to search for menubuttons.
  985.  
  986. proc tkFirstMenu w {
  987.     set w [tkMenuFind [winfo toplevel $w] ""]
  988.     if {$w != ""} {
  989.     if {[winfo class $w] == "Menu"} {
  990.         tk_menuSetFocus $w
  991.         set tkPriv(window) $w
  992.         tkSaveGrabInfo $w
  993.         grab -global $w
  994.         tkMenuFirstEntry $w
  995.     } else {
  996.         tkMbPost $w
  997.         tkMenuFirstEntry [$w cget -menu]
  998.     }
  999.     }
  1000. }
  1001.  
  1002. # tkTraverseWithinMenu
  1003. # This procedure implements keyboard traversal within a menu.  It
  1004. # searches for an entry in the menu that has "char" underlined.  If
  1005. # such an entry is found, it is invoked and the menu is unposted.
  1006. #
  1007. # Arguments:
  1008. # w -                The name of the menu widget.
  1009. # char -            The character to look for;  case is
  1010. #                ignored.  If the string is empty then
  1011. #                nothing happens.
  1012.  
  1013. proc tkTraverseWithinMenu {w char} {
  1014.     if {$char == ""} {
  1015.     return
  1016.     }
  1017.     set char [string tolower $char]
  1018.     set last [$w index last]
  1019.     if {$last == "none"} {
  1020.     return
  1021.     }
  1022.     for {set i 0} {$i <= $last} {incr i} {
  1023.     if [catch {set char2 [string index \
  1024.         [$w entrycget $i -label] \
  1025.         [$w entrycget $i -underline]]}] {
  1026.         continue
  1027.     }
  1028.     if {[string compare $char [string tolower $char2]] == 0} {
  1029.         if {[$w type $i] == "cascade"} {
  1030.         $w activate $i
  1031.         $w postcascade active
  1032.         event generate $w <<MenuSelect>>
  1033.         set m2 [$w entrycget $i -menu]
  1034.         if {$m2 != ""} {
  1035.             tkMenuFirstEntry $m2
  1036.         }
  1037.         } else {
  1038.         tkMenuUnpost $w
  1039.         uplevel #0 [list $w invoke $i]
  1040.         }
  1041.         return
  1042.     }
  1043.     }
  1044. }
  1045.  
  1046. # tkMenuFirstEntry --
  1047. # Given a menu, this procedure finds the first entry that isn't
  1048. # disabled or a tear-off or separator, and activates that entry.
  1049. # However, if there is already an active entry in the menu (e.g.,
  1050. # because of a previous call to tkPostOverPoint) then the active
  1051. # entry isn't changed.  This procedure also sets the input focus
  1052. # to the menu.
  1053. #
  1054. # Arguments:
  1055. # menu -        Name of the menu window (possibly empty).
  1056.  
  1057. proc tkMenuFirstEntry menu {
  1058.     if {$menu == ""} {
  1059.     return
  1060.     }
  1061.     tk_menuSetFocus $menu
  1062.     if {[$menu index active] != "none"} {
  1063.     return
  1064.     }
  1065.     set last [$menu index last]
  1066.     if {$last == "none"} {
  1067.     return
  1068.     }
  1069.     for {set i 0} {$i <= $last} {incr i} {
  1070.     if {([catch {set state [$menu entrycget $i -state]}] == 0)
  1071.         && ($state != "disabled") && ([$menu type $i] != "tearoff")} {
  1072.         $menu activate $i
  1073.         tkGenerateMenuSelect $menu
  1074.         if {[$menu type $i] == "cascade"} {
  1075.         set cascade [$menu entrycget $i -menu]
  1076.         if {[string compare $cascade ""] != 0} {
  1077.             $menu postcascade $i
  1078.             tkMenuFirstEntry $cascade
  1079.         }
  1080.         }
  1081.         return
  1082.     }
  1083.     }
  1084. }
  1085.  
  1086. # tkMenuFindName --
  1087. # Given a menu and a text string, return the index of the menu entry
  1088. # that displays the string as its label.  If there is no such entry,
  1089. # return an empty string.  This procedure is tricky because some names
  1090. # like "active" have a special meaning in menu commands, so we can't
  1091. # always use the "index" widget command.
  1092. #
  1093. # Arguments:
  1094. # menu -        Name of the menu widget.
  1095. # s -            String to look for.
  1096.  
  1097. proc tkMenuFindName {menu s} {
  1098.     set i ""
  1099.     if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {
  1100.     catch {set i [$menu index $s]}
  1101.     return $i
  1102.     }
  1103.     set last [$menu index last]
  1104.     if {$last == "none"} {
  1105.     return
  1106.     }
  1107.     for {set i 0} {$i <= $last} {incr i} {
  1108.     if ![catch {$menu entrycget $i -label} label] {
  1109.         if {$label == $s} {
  1110.         return $i
  1111.         }
  1112.     }
  1113.     }
  1114.     return ""
  1115. }
  1116.  
  1117. # tkPostOverPoint --
  1118. # This procedure posts a given menu such that a given entry in the
  1119. # menu is centered over a given point in the root window.  It also
  1120. # activates the given entry.
  1121. #
  1122. # Arguments:
  1123. # menu -        Menu to post.
  1124. # x, y -        Root coordinates of point.
  1125. # entry -        Index of entry within menu to center over (x,y).
  1126. #            If omitted or specified as {}, then the menu's
  1127. #            upper-left corner goes at (x,y).
  1128.  
  1129. proc tkPostOverPoint {menu x y {entry {}}}  {
  1130.     global tcl_platform
  1131.     
  1132.     if {$entry != {}} {
  1133.     if {$entry == [$menu index last]} {
  1134.         incr y [expr -([$menu yposition $entry] \
  1135.             + [winfo reqheight $menu])/2]
  1136.     } else {
  1137.         incr y [expr -([$menu yposition $entry] \
  1138.             + [$menu yposition [expr $entry+1]])/2]
  1139.     }
  1140.     incr x [expr -[winfo reqwidth $menu]/2]
  1141.     }
  1142.     $menu post $x $y
  1143.     if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} {
  1144.     $menu activate $entry
  1145.     tkGenerateMenuSelect $menu
  1146.     }
  1147. }
  1148.  
  1149. # tkSaveGrabInfo --
  1150. # Sets the variables tkPriv(oldGrab) and tkPriv(grabStatus) to record
  1151. # the state of any existing grab on the w's display.
  1152. #
  1153. # Arguments:
  1154. # w -            Name of a window;  used to select the display
  1155. #            whose grab information is to be recorded.
  1156.  
  1157. proc tkSaveGrabInfo w {
  1158.     global tkPriv
  1159.     set tkPriv(oldGrab) [grab current $w]
  1160.     if {$tkPriv(oldGrab) != ""} {
  1161.     set tkPriv(grabStatus) [grab status $tkPriv(oldGrab)]
  1162.     }
  1163. }
  1164.  
  1165. # tkRestoreOldGrab --
  1166. # Restores the grab to what it was before TkSaveGrabInfo was called.
  1167. #
  1168.  
  1169. proc tkRestoreOldGrab {} {
  1170.     global tkPriv
  1171.  
  1172.     if {$tkPriv(oldGrab) != ""} {
  1173.  
  1174.         # Be careful restoring the old grab, since it's window may not
  1175.     # be visible anymore.
  1176.  
  1177.     catch {
  1178.         if {$tkPriv(grabStatus) == "global"} {
  1179.         grab set -global $tkPriv(oldGrab)
  1180.         } else {
  1181.         grab set $tkPriv(oldGrab)
  1182.         }
  1183.     }
  1184.     set tkPriv(oldGrab) ""
  1185.     }
  1186. }
  1187.  
  1188. proc tk_menuSetFocus {menu} {
  1189.     global tkPriv
  1190.     if {![info exists tkPriv(focus)] || [string length $tkPriv(focus)] == 0} {
  1191.     set tkPriv(focus) [focus]
  1192.     }
  1193.     focus $menu
  1194. }
  1195.     
  1196. proc tkGenerateMenuSelect {menu} {
  1197.     global tkPriv
  1198.  
  1199.     if {([string compare $tkPriv(activeMenu) $menu] == 0) \
  1200.         && ([string compare $tkPriv(activeItem) [$menu index active]] \
  1201.         == 0)} {
  1202.     return
  1203.     }
  1204.  
  1205.     set tkPriv(activeMenu) $menu
  1206.     set tkPriv(activeItem) [$menu index active]
  1207.     event generate $menu <<MenuSelect>>
  1208. }
  1209.  
  1210. # tk_popup --
  1211. # This procedure pops up a menu and sets things up for traversing
  1212. # the menu and its submenus.
  1213. #
  1214. # Arguments:
  1215. # menu -        Name of the menu to be popped up.
  1216. # x, y -        Root coordinates at which to pop up the
  1217. #            menu.
  1218. # entry -        Index of a menu entry to center over (x,y).
  1219. #            If omitted or specified as {}, then menu's
  1220. #            upper-left corner goes at (x,y).
  1221.  
  1222. proc tk_popup {menu x y {entry {}}} {
  1223.     global tkPriv
  1224.     global tcl_platform
  1225.     if {($tkPriv(popup) != "") || ($tkPriv(postedMb) != "")} {
  1226.     tkMenuUnpost {}
  1227.     }
  1228.     tkPostOverPoint $menu $x $y $entry
  1229.     if {$tcl_platform(platform) == "unix"} {
  1230.     tkSaveGrabInfo $menu
  1231.     grab -global $menu
  1232.     set tkPriv(popup) $menu
  1233.     tk_menuSetFocus $menu
  1234.     }
  1235. }
  1236.